home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1996 / MacHack 1996.toast / Hacks / Hacks ’87 / Source ƒ.sit / Source ƒ / communications source ƒ / Vax Xmodem to MacTerminal / MACX.FOR < prev    next >
Encoding:
Text File  |  1987-02-21  |  34.7 KB  |  1,309 lines  |  [TEXT/MARC]
  1. c    MACX.FOR v3.2
  2. c    *********************************************************
  3. c    *                            *
  4. c    *    This subprogram copyright (c) 1985 by        *
  5. c    *    Eye Research Institute of Retina Foundation    *
  6. c    *        ALL RIGHTS RESERVED            *
  7. c    *                            *
  8. c    *********************************************************
  9. c        28 Dec 84
  10. c
  11. c    modification history:
  12. c
  13. c        March 21, 1985 - Vern Keenan
  14. c            added READONLY to all the STATUS=OLD OPENs so
  15. c            files from another user's directory can be read.
  16. c
  17. c    For UPLOADING and DOWNLOADING complete Mac files from the VAX.
  18. c        Prototype version, but format of VAX/VMS files is now
  19. c        stable and I don't expect to change it.
  20. c
  21. c        Text conversion to/from VMS is NOT yet included.
  22. c        Macintosh files are NOT in a format that can be directly
  23. c        used by VMS.  Record length is 128 bytes.  The first
  24. c        record contains file header information.  You can use the
  25. c        routine READXMMAC to read it.  Data and resource forks
  26. c        follow in that order; length is actual length rounded up
  27. c        to multiple of 128.
  28. c
  29. c    Dan Smith
  30. C    Eye Research Institute of Retina Foundation
  31. c    20 Staniford Street
  32. c    Boston, MA 02114
  33. c
  34. c        (617) 742-3140
  35. c        CIS 74706,661
  36. c
  37. c    Based on J. James Belonis II's XMODEM program
  38. c
  39. c    Completely reworked for use with MacTerminal
  40. c
  41. c    Compile, link, RUN MACX, then use commands
  42. c
  43. c        R filename
  44. c        S filename
  45. c
  46. c        works with MacTerminal with File Transfer Settings
  47. c            XMODEM/MacTerminal
  48. c
  49. c        based on
  50. c               XMODEM54.FOR  (Version 5.4)   Updated 5/14/84
  51. c               J.James Belonis II
  52. c               Physics Hall FM-15
  53. c               University of Washington
  54. c               Seattle, WA 98195
  55. c
  56. c  TMODEM.C written by Richard Conn, Eliot Moss, and Lauren
  57. c   Weinstein
  58. c
  59.     external macxcld,errou
  60.     external giveup
  61.     logical cli$dcl_parse,st
  62.     character line*80
  63.         INTEGER*2 CHAN,STATUS(4)
  64.         COMMON /QIO/ CHAN,STATUS
  65. c  log file for debugging
  66. D    open(8,file='MACX.LOG',carriagecontrol='LIST',status='NEW')
  67. c  assign terminal channel for QIO calls to send raw bytes.
  68.     call sys$assign('TT',chan,,)
  69.     call userex(giveup)
  70.     write(*,*)'MACX v3.2, copyright (c) 1985 by Eye Research Institute'
  71.     1//' of Retina Foundation'
  72.     write(*,*)'All rights reserved'
  73.     iforceprompt=0
  74. 50    write(*,*)'H)elp, C)atalog, U)pload, D)ownload, Q)uit'
  75.     write(*,*)
  76. 100    continue
  77.     call lib$get_foreign(line,'MACX>',,iforceprompt)
  78. c
  79. c For the call to dcl_parse, avoid standard error handling.  Use our own
  80. c    routine, which does nothing.  Then call "revert" to reestablish
  81. c    standard error handling.
  82. c
  83.     call lib$establish(errou)
  84.         st=cli$dcl_parse(line,macxcld)
  85.     call lib$revert    
  86. c
  87.     if(st)then
  88.         call cli$dispatch
  89.     else
  90.         write(*,*)'Bad command'
  91.     end if
  92.     go to 50
  93.     end
  94.     integer function errou(sigargs,mechargs)
  95.     include '($ssdef)'
  96.     integer sigargs(*),mechargs(5)
  97.     errou=ss$_continue
  98.     return
  99.     end
  100.     subroutine quit
  101.     call exit
  102.     end
  103.     subroutine help
  104.     external lib$put_output,lib$get_input
  105.     call lbr$output_help(
  106.     1    lib$put_output,
  107.     2    80,
  108.     3    'macx',
  109.     4    'userc:[sci04444.macx]macx',
  110.     5    ,
  111.     6    lib$get_input)
  112.     return
  113.     end
  114.     subroutine import
  115. c    *********************************************************
  116. c    *                            *
  117. c    *    This subprogram copyright (c) 1985 by        *
  118. c    *    Eye Research Institute of Retina Foundation    *
  119. c    *        ALL RIGHTS RESERVED            *
  120. c    *                            *
  121. c    *********************************************************
  122.     implicit integer(a-z)
  123.     logical status,cli$present,cli$get_value,textmode,lib$find_file
  124.     character*80 file,outfile,filespec,temp
  125.     call cli$get_value('file',filespec)
  126.     status=lib$find_file(filespec,file,context,'[].txt')
  127.     if(.not.status)then
  128.         write(*,*)'Not found: '//filespec
  129.         return
  130.     endif
  131.     i=index(file,']')
  132.     temp=file(i+1:)
  133.     j=index(temp,'.')-1
  134.     outfile=file(1:i)//temp(1:j)
  135.     if(cli$present('out'))then
  136.         call cli$get_value('out',outfile)
  137.     endif
  138.     call textmac(file,outfile)
  139.     return
  140.     end
  141.     function intparam(aname,idefault)
  142. c    *********************************************************
  143. c    *                            *
  144. c    *    This subprogram copyright (c) 1985 by        *
  145. c    *    Eye Research Institute of Retina Foundation    *
  146. c    *        ALL RIGHTS RESERVED            *
  147. c    *                            *
  148. c    *********************************************************
  149.     character aname*(*),aval*32
  150.     logical cli$present,cli$get_value
  151.     intparam=idefault
  152.     if(cli$present(aname))then
  153.         call cli$get_value(aname,aval)
  154.         read(aval,100,err=200)ival
  155. 100        format(bn,i32)
  156.         intparam=ival
  157. 200        continue
  158.     end if
  159.     return
  160.     end
  161.     subroutine export
  162. c    *********************************************************
  163. c    *                            *
  164. c    *    This subprogram copyright (c) 1985 by        *
  165. c    *    Eye Research Institute of Retina Foundation    *
  166. c    *        ALL RIGHTS RESERVED            *
  167. c    *                            *
  168. c    *********************************************************
  169.     logical status,cli$present,cli$get_value,textmode,lib$find_file
  170.     character*80 file,outfile,filespec,temp
  171.     character macname*63,type*4,creator*4
  172.     call cli$get_value('file',filespec)
  173.     status=lib$find_file(filespec,file,context,'[].mac')
  174.     if(.not.status)then
  175.         write(*,*)'Not found: '//filespec
  176.         return
  177.     endif
  178.     call readxmmac(file,macname,n,type,creator,i,j,k,l)
  179.     if(type.ne.'TEXT')then
  180.         write(*,*)'Not a TEXT file, can''t export'
  181.         return
  182.     endif
  183.     i=index(file,']')
  184.     temp=file(i+1:)
  185.     j=index(temp,'.')-1
  186.     outfile=file(1:i)//temp(1:j)
  187.     if(cli$present('out'))then
  188.         call cli$get_value('out',outfile)
  189.     endif
  190.     call mactext(file,outfile)
  191.     return
  192.     end
  193.     subroutine vmsname(macin,vmsout)
  194. c    *********************************************************
  195. c    *                            *
  196. c    *    This subprogram copyright (c) 1985 by        *
  197. c    *    Eye Research Institute of Retina Foundation    *
  198. c    *        ALL RIGHTS RESERVED            *
  199. c    *                            *
  200. c    *********************************************************
  201.     implicit integer(a-z)
  202.     character mac*63,vms*9,macin*(*),vmsout*(*),c
  203.     mac=macin
  204.     v=0
  205.     vms=' '
  206.     do 100 i=1,63
  207.     c=mac(i:i)
  208.     if(
  209.     1    (c.ge.'A'.and.c.le.'Z')
  210.     2  .or. (c.ge.'a'.and.c.le.'z')
  211.     3  .or. (c.ge.'0'.and.c.le.'9')
  212.     4                     ) then
  213.         if(v.lt.9)then
  214.             v=v+1
  215.             vms(v:v)=c
  216.         endif
  217.     endif
  218. 100    continue
  219.     vmsout=vms
  220.     return
  221.     end
  222.     subroutine upload
  223. c    *********************************************************
  224. c    *                            *
  225. c    *    This subprogram copyright (c) 1985 by        *
  226. c    *    Eye Research Institute of Retina Foundation    *
  227. c    *        ALL RIGHTS RESERVED            *
  228. c    *                            *
  229. c    *********************************************************
  230.     implicit integer(a-z)
  231.     logical status,cli$present,cli$get_value,textmode
  232.     character*80 file,tempfile
  233.     if(.not. cli$get_value('file',file))file=' '
  234.     textmode=cli$present('TEXT')
  235.     write(*,*)'Please send your file.'
  236.     write(*,*)'     (pull down "File," select "Send File...")'
  237.     write(*,*)
  238.     if(textmode)then
  239.         tempfile='macx.tmp;1'
  240.         call recvfile(tempfile)
  241.         call mactext(tempfile,file)
  242.         call deletefile(tempfile)
  243.     else
  244.         call recvfile(file)
  245.     end if
  246.     return
  247.     end
  248.     subroutine download
  249. c    *********************************************************
  250. c    *                            *
  251. c    *    This subprogram copyright (c) 1985 by        *
  252. c    *    Eye Research Institute of Retina Foundation    *
  253. c    *        ALL RIGHTS RESERVED            *
  254. c    *                            *
  255. c    *********************************************************
  256.     implicit integer(a-z)
  257.     logical status,cli$present,cli$get_value,textmode
  258.     character*80 infilespec,prevspec,infile,tempfile
  259.     go to 1000
  260. 50    count=0
  261. 100    continue
  262.     status=lib$find_file(infilespec,infile,context,'.MAC',prevspec)
  263.     prevspec=infilespec
  264.     if(status)then
  265.         count=count+1
  266.         textmode=cli$present('TEXT')
  267.         if(textmode)then
  268.             tempfile='macx.tmp;1'
  269.             call textmac(infile,tempfile)
  270.             call sendfile(tempfile)
  271.             call deletefile(tempfile)
  272.         else
  273.             call sendfile(infile)
  274.         endif
  275.         go to 100
  276.     end if
  277.     if(count.eq.0)write(*,*)'No files matching:'//
  278.     1    infile(1:length(infile))
  279. c
  280. 1000    if(cli$get_value('file',infilespec))go to 50
  281. c
  282. c
  283.     return
  284.     end
  285.     subroutine deletefile(file)
  286.     character*(*) file
  287.     open(unit=1,status='unknown',file=file,dispose='delete')
  288.     close(unit=1)
  289.     return
  290.     end
  291.     function length(a)
  292.     character*(*) a
  293.     length=1
  294.     l=len(a)
  295.     do 100 i=1,l
  296. 100    if(a(i:i).ne.' ')length=i
  297.     return
  298.     end
  299. c----------------------------------------------------------------
  300. c  send file
  301.     subroutine sendfile(file)
  302.  
  303. c  declare variables
  304. C  QIO.DCK to be included in subroutines using SYS$QIOW
  305.  
  306.         INTEGER*2 CHAN,STATUS(4)
  307.         COMMON /QIO/ CHAN,STATUS
  308.     logical macfirst
  309.     character*(*) file
  310.     byte sector(130), c
  311.     byte brecord(128)
  312.     equivalence(brecord,sector)
  313.     integer block, blocknumber, nakwait, stat, ic
  314.     logical ttyinlim
  315.     logical charintime, acked
  316.  
  317.  
  318.     integer errorcount
  319.     common /err/errorcount
  320.  
  321.     integer high,low
  322.     common /crcval/high,low
  323.  
  324.     logical crc
  325.     integer checksum
  326.     common /checks/checksum,crc
  327.  
  328.     equivalence (checksum,checksumbyte)
  329.     equivalence (ic,c)
  330.  
  331.  
  332. c  define ASCII characters
  333.     parameter NUL=0
  334.     parameter SOH=1
  335.     parameter EOT=4
  336.     parameter ACK=6
  337.     parameter NAK=21
  338.     parameter CAN=24
  339. c  timeouts
  340.     parameter respnaklim=10
  341.     parameter naklim=10
  342.     parameter eotlim=10
  343.     parameter errlim=3
  344.  
  345.     character macname*63,type*4,creator*4
  346.     dimension isection(2)
  347.  
  348.     call readxmmac(file,macname,n,type,creator,idat,ires,
  349.     1    idum,idum)
  350.     ndat=(idat+127)/128
  351.     nres=(ires+127)/128
  352.     write(*,10)macname(1:n),idat,ires,idat+ires
  353. 10    format(' Sending: ',a/5x,i8,' bytes (data)',i8,
  354.     1 ' bytes (resource)',i8,' bytes (total)')
  355.     call delay(0.1) ! 4.0
  356. c
  357.     isection(1)=2
  358.     isection(2)=2+ndat
  359. c
  360.     open(6,name=file,iostat=stat,status='OLD',defaultfile='.mac',
  361.     1    readonly)
  362. c     1         carriagecontrol='NONE',recordtype='FIXED',recl=128)
  363.  
  364.     if(stat) then
  365.         write(*,*)' Can''t open '//file
  366.             call exit
  367.     endif
  368.        call ttyout(27,1)
  369.        call ttyout(97,1)
  370.        macfirst=.true.
  371. c
  372. c
  373. c
  374.     errorcount=0
  375.     block=1
  376.     blocknumber=1
  377.     nakwait=0
  378.     crc=.false.
  379.  
  380. c  await first NAK (or 'C') indicating receiver is ready
  381.   200       charintime=ttyinlim(c,1,naklim)         ! return NUL if timeout
  382. c           print *,' character=',c
  383.         if( .NOT.charintime ) then
  384.                 nakwait=nakwait+1
  385. c  give the turkey 10 seconds to figure out how to receive a file
  386.                 if(nakwait.EQ.10) call cancel
  387.                 goto 200
  388.         elseif(c.EQ.NAK) then
  389.                 crc=.false.
  390.         elseif(c.EQ.CAN) then
  391.                 call cancel
  392.         elseif(c.eq.ACK .and. macfirst) then
  393.             crc=.false.
  394.             call delay(1.0)
  395.         else
  396. c  unrecognized character
  397.                 nakwait=nakwait+1
  398.                 if(nakwait.eq.10) call cancel
  399.                 goto 200
  400.         endif
  401.         macfirst=.false.
  402.   300   continue
  403. c  send new sector
  404.     do 350 i=1,2
  405.     if(block.eq.isection(i))then
  406. c
  407. c Mark end of section
  408. c    Note--send EOT but DON'T wait for ACK
  409. c
  410. D    WRITE(8,*)' About to mark end of section',i,isection(i)
  411.   310        call delay(1.0) ! 3.0
  412.         call ttyout(EOT,1)
  413.         call getack(acked)
  414.         if(.not.acked)goto310
  415.         charintime=ttyinlim(c,1,naklim)
  416.         if(.not.charintime)call cancel
  417.         if(c.ne.nak)call cancel
  418.         blocknumber=1
  419.         call delay(1.0) ! 3.0
  420.     end if
  421.   350    continue
  422. D    WRITE(8,*)' About to read block',block
  423.     read(6,1000,end=500) (sector(i),i=1,128)
  424. c
  425.  1000   format(128a)
  426.     errorcount=0
  427. c       print *,' sector as read',sector
  428.   400   continue
  429. c  send sector
  430. c       print *,' SOH '
  431.     call ttyout(SOH,1)
  432.     call ttyout(blocknumber,1)
  433.     call ttyout( not(blocknumber),1 )
  434. c       print *,' blocknumber=',blocknumber
  435.  
  436.     checksum=0
  437. c  separate calls to slow down in case other end slow (can even introduce
  438. c  delay between characters).
  439.     do i=1,128
  440.             call ttyout(sector(i),1)
  441.     enddo
  442. c        call ttyout(sector(i),128)
  443. c  calc checksum or crc
  444.             do i=1,128
  445.                     checksum=checksum+sector(i)
  446.             enddo
  447. c  this sends low order byte of checksum
  448.             call ttyout(checksum,1)
  449. c               print *,' checksum',checksum
  450.  
  451. c  sector sent, see if receiver acknowleges
  452. c  getack attempts to get ACK
  453. c  if not, repeat sector
  454. c       print*, ' should wait for ACK 10 seconds'
  455.     call getack(acked)
  456. c       print*, ' getack returned=',acked
  457.     if(.NOT.acked) goto 400
  458.  
  459. c  ACK received, send next sector
  460.     block=block+1
  461.     blocknumber=blocknumber+1
  462.     goto 300
  463.  
  464. c  end of file during read.  finish up sending.
  465.   500   continue
  466. c
  467. c Mark end of section
  468. c
  469.   510        call ttyout(EOT,1)
  470. c      getack attempts to get ACK up to errlim times
  471.         call getack(acked)
  472.         if( .NOT.acked ) goto 510
  473.  
  474. c       print *,' Sending complete.'
  475.     close(6)
  476.     close(8,dispose='DELETE')
  477.     write(*,*)char(0)//char(0)//char(0)//char(0)
  478. c    call delay(1.0)
  479.     return
  480.     end
  481.  
  482. c----------------------------------------------------------------
  483. c  receive file
  484.     subroutine recvfile(file)
  485.  
  486. c  declare variables
  487.  
  488.         INTEGER*2 CHAN,STATUS(4)
  489.         COMMON /QIO/ CHAN,STATUS
  490.     character*(*) file
  491.     character macname*63,vmsfile*80
  492.     byte sector(130), c, notc, checksumbyte, ck
  493.     byte brecord(128)
  494.     equivalence(brecord,sector)
  495.     integer blocknumber, inotc, notnotc, secbytes, stat
  496.     integer testblock, testprev, ic
  497.     logical ttyinlim
  498.     logical charintime, firstsoh
  499.  
  500.     integer errorcount
  501.     common /err/errorcount
  502.  
  503.     integer high,low
  504.     common /crcval/high,low
  505.  
  506.     logical opened
  507.     integer checksum
  508.     common /checks/checksum,crc
  509.  
  510.     equivalence (checksum,checksumbyte)
  511.     equivalence (ic,c)
  512.  
  513. c  define ASCII characters
  514.     parameter NUL=0
  515.     parameter SOH=1
  516.     parameter EOT=4
  517.     parameter ACK=6
  518.     parameter NAK=21
  519.     parameter CAN=24
  520.     parameter SUB=26
  521. c  timeouts
  522.     parameter respnaklim=10
  523.     parameter naklim=10
  524.     parameter eotlim=10
  525.     parameter errlim=10
  526.  
  527.  
  528.     call passall(CHAN,.TRUE.)
  529.     opened=.false.
  530.     secbytes=129
  531. c
  532.         i=0
  533. 70        last=i
  534.         call ttyin(i,1)
  535.         if(.not.(last.eq.27 .and. i.eq.97))go to 70
  536.         do 1000 macfirst=1,3
  537. c
  538.         if(macfirst.eq.1)then
  539.             call ttyout(ack,1)
  540.         else
  541.             call ttyout(nak,1)
  542.         endif
  543.  
  544.  
  545.     firstsoh=.false.
  546.     errorcount=0
  547.     blocknumber=1
  548.     j=0
  549.  
  550.  
  551.   800   continue
  552. D    WRITE(8,*) ' ready for SOH'
  553. c  must allow enough time for other's disk read (xmodem50.asm allows 10 sec)
  554.     charintime=ttyinlim(c,1,respnaklim)
  555. c  if no char for a while, try NAK or C again
  556.     if( .NOT.charintime ) then
  557. c               print*,' no response to NAK or C, trying again'
  558. D    WRITE(8,*) ' no response to NAK or C, trying again'
  559.             goto 999
  560.     endif
  561. c  else received a char so see what it is
  562.     if(c.eq.NUL) goto 800   ! ignore nulls here for compatablity with old
  563.                             ! versions of modem7
  564.     if(c.EQ.CAN) then
  565.             print *,' Canceled.  Aborting.'
  566. D    WRITE(8,*) ' Canceled.  Aborting.'
  567.             call exit
  568.     endif
  569. D    WRITE(8,*) ' EOT or SOH character=',c
  570.     if(c.NE.EOT) then
  571.             IF(c.NE.SOH) then
  572. D    WRITE(8,*) ' Not SOH, was decimal ',c
  573.                     goto 999
  574.             endif
  575.             firstsoh=.true.
  576.  
  577. c  character was SOH to indicate start of header
  578. c  get block number and complement
  579.             call ttyin(c,1)
  580. D    WRITE(8,*) ' block=',c
  581.  
  582.             call ttyin(notc,1)
  583. D    WRITE(8,*) ' block complement=',notc
  584.             inotc=notc      ! make integer for "not" function
  585.             notnotc=iand( not(inotc),255 )  ! mask back to byte
  586.  
  587. c  c is low order byte of ic via equivalence statement
  588.             if(ic.NE.notnotc) then
  589. D    WRITE(8,*) ' block check bad.'
  590.                     goto 999
  591.             endif
  592. c  block number valid but not yet checked against expected
  593.  
  594.             checksum=0
  595.  
  596. c  receive the sector and checksum bytes in one call (for speed).
  597. c  secbytes is 129 for checksum, 130 for CRC
  598.             call ttyin(sector,secbytes)
  599.  
  600. c  don't add received checksum byte to checksum
  601.                     do i=1,secbytes-1
  602.                             checksum=checksum+sector(i)
  603.                     enddo
  604.                     ck=sector(129)
  605. D    WRITE(8,2100) ck
  606.  
  607. D    WRITE(8,2100) checksum
  608. D    WRITE(8,2100) checksumbyte
  609. c 2100                  format(' checksum=',z10)
  610.                     if( checksumbyte.NE.ck ) then
  611. D    WRITE(8,*) ' bad checksum'
  612.                             goto 999
  613.                     endif
  614.  
  615. c  received OK so we can believe the block number, see which block it was
  616. c  mask it to be one byte
  617.             testblock=iand(blocknumber,255)
  618.             testprev=iand( blocknumber-1 ,255)
  619.             if( ic.EQ.testprev) then
  620. D    WRITE(8,*) ' prev. block again, out of synch'
  621. c  already have this block so don't write it, but ACK anyway to resynchronize
  622.                     goto 985
  623.             elseif( ic.NE.testblock ) then
  624. D    WRITE(8,*) ' block number bad.'
  625.                     goto 999
  626.             endif
  627. c  else was expected block
  628.  
  629. c  write before acknowlege so not have to listen while write.
  630.         if(.not.opened)then
  631.             vmsfile=file
  632. D    WRITE(8,*)'opening, vmsfile',vmsfile
  633.             n=sector(2)
  634.             macname=' '
  635.             do i=1,n
  636.                 macname(i:i)=char(sector(i+2))
  637.             end do
  638. D    WRITE(8,*)'macname',macname
  639.             if(vmsfile.eq.' ')then
  640.                 call vmsname(macname,vmsfile)
  641.             write(8,*)'vmsfile',vmsfile
  642.             endif
  643.         open(7,name=vmsfile,recl=128,status='NEW',iostat=stat,
  644.     1          carriagecontrol='NONE',recordtype='FIXED',
  645.     2    defaultfile='.mac')
  646.             if(stat) then
  647.                 write(*,*)' Can''t open '//file
  648.                     call exit
  649.             endif
  650.         opened=.true.
  651.         endif
  652.                  write(7,2000,err=900) (sector(i),i=1,128)
  653.  2000                format(128a)
  654.             goto 975
  655. 900    continue
  656. D    WRITE(8,*) ' Can''t write sector. Aborting.'
  657.             print*, ' Can''t write sector. Aborting.'
  658.             call exit
  659.  
  660.   975           continue
  661. c  recieved sector ok, wrote it ok, so acknowlege it to request next.
  662.             blocknumber=blocknumber+1
  663. c  comes here if re-received the previous sector
  664.   985           continue
  665.             errorcount=0
  666. D    WRITE(8,*) ' ACKing, sector was ok.'
  667.             call ttyout(ACK,1)
  668.             goto 800
  669.  
  670. c  else error so eat garbage in case out of synch and try again
  671.   999           continue
  672.             call eat
  673. D    WRITE(8,*) ' receive error NAK, block=',blocknumber
  674.                     call ttyout(NAK,1)
  675.             errorcount=errorcount+1
  676.   998           if(errorcount.GE.errlim) then
  677.                     print*,' Unable to receive block. Aborting.'
  678. D    WRITE(8,*) ' Not receive block. Aborting.'
  679. c  delete incompletely received file
  680.                     close(7,dispose='DELETE')
  681.                     call exit
  682.             endif
  683. c  retry
  684.             goto 800
  685.     endif
  686.  
  687. c  EOT received instead of SOH so file done.
  688. c  should keep sending ACK 'til no more EOT's ?
  689.     if (j.NE.0) then
  690.     write(7,2000,err=900) (sector(i),i=1,j)
  691.     endif
  692.     call ttyout(ACK,1)
  693. 1000    continue
  694.     close(7)
  695.     close(8,dispose='DELETE')
  696.     m=length(macname)
  697.     n=length(vmsfile)
  698.     write(*,*)'Received Macintosh file '//macname(1:m)
  699.     write(*,*)'            as VMS file '//vmsfile(1:n)//'.MAC'
  700.     return
  701.     end
  702.  
  703. c-------------------------------------------------------------
  704. c-----------------------------------------------------------
  705. c-----------------------------------------------------------
  706.       SUBROUTINE TTYIN(LINE,N)
  707.       BYTE LINE(*)
  708.       INTEGER N
  709. C              READ CHARACTERS FROM TERMINAL
  710. C              MODIFIED BY BELONIS TO REMOVE PRIVILEGE
  711. C              MAY HAVE PROBLEM WITH TYPE-AHEAD
  712. c  should convert to time-out properly with loops in main ?
  713.  
  714.         INTEGER*2 CHAN,STATUS(4)
  715.         COMMON /QIO/ CHAN,STATUS
  716. c      INCLUDE '($SSDEF)'
  717.       parameter ss$_timeout='22c'x
  718.       INTEGER I
  719.       INTEGER SYS$QIOW
  720.       INTEGER*4 terminators(2)
  721.  
  722. c      logical crc
  723. c      integer checksum
  724. c      common /checks/checksum,crc
  725.  
  726.       EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED
  727.       DATA terminators/0,0/
  728. C
  729. D    WRITE(8,*) ' inside ttyin, N=',N
  730.       I = SYS$QIOW(,           !EVENT FLAG
  731.      -              %VAL(CHAN),         !CHANNEL
  732.      -              %VAL(%LOC(IO$_TTYREADALL).OR.
  733.      -                   %LOC(IO$M_NOECHO)),         !   .OR.%LOC(IO$M_TIMED)),
  734.      -              STATUS,,,
  735.      -              LINE,       !BUFFER
  736.      -              %VAL(N),    !LENGTH
  737.      -              ,           ! max time   beware other disk time
  738.      -                          !            and Quit or Retry time
  739.      -              terminators,,)  !no terminators
  740. c      if(crc) then
  741. D    WRITE(8,1000) (LINE(j),j=1,N)
  742. D    WRITE(8,*) ' status=',STATUS
  743. c      else
  744. D    WRITE(8,2000) (line(j),j=1,N)
  745. D    WRITE(8,*) ' status=',status
  746. c      endif
  747.  1000 format(' ttyin=',6(20z3/),10z3)
  748.  2000 format(' ttyin=',6(20z3/),9z3)
  749. c      if(STATUS(1).EQ.SS$_TIMEOUT) THEN
  750. D    WRITE(8,*) ' 10 second timeout in ttyin'
  751. c         print*,    ' 10 second timeout in ttyin'
  752. c         call exit
  753. c      endif
  754.  
  755.       IF (I) THEN
  756. D    WRITE(8,*) ' returning from ttyin'
  757.      return
  758.       endif
  759. C
  760. C              ERROR
  761. D    WRITE(8,*) ' ttyin error.'
  762.       CALL SYS$EXIT( %VAL(I) )
  763.       END
  764. c-----------------------------------------------------------
  765.     subroutine eat
  766. c  eats extra characters 'til 1 second pause   used to re-synch after error
  767.     byte buffer(135)
  768.     integer numchar
  769.     logical i,ttyinlim
  770. c
  771.     parameter maxtime=1
  772. c  in case mis-interpreted header, allow at least 1 block of garbage
  773.     numchar=135
  774.  
  775.     i=ttyinlim(buffer,numchar,maxtime)
  776. c       print*,' finished eating'
  777. D    WRITE(8,*) ' finished eating'
  778.     return
  779.     end
  780. c-----------------------------------------------------------
  781.       LOGICAL FUNCTION TTYINLIM(LINE,N,LIMIT)
  782.       BYTE LINE(*)
  783.       INTEGER N,LIMIT
  784. C              READ CHARACTERS FROM TERMINAL
  785. C              WITH TIME LIMIT, RETURN FALSE IF NO CHARACTERS
  786. C              RECEIVED FOR LIMIT SECONDS
  787. C              MODIFIED BY BELONIS TO REMOVE PRIVILEGE PROBLEM
  788. C              MAY HAVE PROBLEM WITH TYPE-AHEAD
  789.  
  790.         INTEGER*2 CHAN,STATUS(4)
  791.         COMMON /QIO/ CHAN,STATUS
  792. c      INCLUDE '($SSDEF)'       ! defines error status returns
  793.       parameter ss$_timeout='22c'x
  794.       INTEGER I
  795.       INTEGER SYS$QIOW
  796.       INTEGER*4 terminators(2)
  797.       EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED
  798.       DATA TERMINATORS/0,0/
  799. C
  800. D    WRITE(8,*) ' inside ttyinlim'
  801.       TTYINLIM=.TRUE.          ! DEFAULT no delay over LIMIT seconds
  802.       I = SYS$QIOW(,           !EVENT FLAG
  803.      -              %VAL(CHAN),         !CHANNEL
  804.      -              %VAL(%LOC(IO$_TTYREADALL).OR.
  805.      -                   %LOC(IO$M_NOECHO).OR.%LOC(IO$M_TIMED)),
  806.      -              STATUS,,,
  807.      -              LINE,       !BUFFER
  808.      -              %VAL(N),   !LENGTH
  809.      -              %VAL(LIMIT),    !time limit in seconds
  810.      -              terminators,,)  !no terminators
  811. c     print*,' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
  812. D    WRITE(8,*) ' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
  813.       if(STATUS(1).EQ.SS$_TIMEOUT) THEN
  814.      TTYINLIM=.FALSE.
  815. D    WRITE(8,*) ' timeout'
  816.      return
  817.       ENDIF
  818.  
  819.       IF (I) THEN
  820. D    WRITE(8,*) ' returning from ttyinlim'
  821.      return
  822.       endif
  823. C
  824. C              ERROR
  825. D    WRITE(8,*) ' ttyinlim error.'
  826.       CALL SYS$EXIT( %VAL(I) )
  827.       END
  828. c-----------------------------------------------------------
  829.       SUBROUTINE TTYOUT(LINE,N)
  830.       BYTE LINE(*)
  831.       INTEGER*2 N
  832. C  output N characters without interpretation
  833.  
  834.         INTEGER*2 CHAN,STATUS(4)
  835.         COMMON /QIO/ CHAN,STATUS
  836.       INTEGER I
  837.       INTEGER SYS$QIOW
  838.       EXTERNAL IO$M_NOFORMAT
  839.       EXTERNAL IO$_WRITEVBLK
  840. C
  841.       IF ( N.LE.0 ) RETURN
  842. C
  843. c       print *, ' to be sent by ttyout ', line(1)
  844.       I = SYS$QIOW(,
  845.      -              %VAL(CHAN),
  846.      -              %VAL(%LOC(IO$_WRITEVBLK).OR.
  847.      -                   %LOC(IO$M_NOFORMAT)),
  848.      -              STATUS,,,
  849.      -              LINE,
  850.      -              %VAL(N),,
  851.      -              %VAL(0),, )         !NO CARRIAGE CONTROL
  852.       if(I) then
  853.      return
  854.       endif
  855. C
  856. C              ERROR
  857. D    WRITE(8,*) ' ttyout error.'
  858.       CALL SYS$EXIT( %VAL(I) )
  859.       END
  860. c--------------------------------------------------
  861.     subroutine giveup
  862. c  this exit routine used especially in case exited via QIO problem
  863.  
  864.         INTEGER*2 CHAN,STATUS(4)
  865.         COMMON /QIO/ CHAN,STATUS
  866.  
  867. c  note: if want log file message, must re-open since
  868. c  system already closed all files before this exit handler got control
  869. c       open(8,file='MACX.LOG',access='APPEND')
  870. D    WRITE(8,*) ' Exit handler.'
  871.  
  872. c  turn off passall
  873.     call passall(CHAN,.FALSE.)
  874.     return
  875.     end
  876. c-----------------------------------------------------
  877.     SUBROUTINE PASSALL(CHAN,SWITCH)
  878. C  sets PASSALL mode for terminal connected to chanel CHAN, ON if switch true
  879.     IMPLICIT INTEGER (A-Z)
  880. c       INCLUDE '($TTDEF)'
  881.     parameter tt$m_passall=1
  882.     parameter tt$m_eightbit='8000'x
  883.     parameter io$_sensemode='27'x
  884.     parameter io$_setmode='23'x
  885. c       INCLUDE '($IODEF)'
  886.     LOGICAL SWITCH
  887.     COMMON/CHAR/CLASS,TYPE,WIDTH,CHARAC(3),LENGTH   !byte reversed LENGTH
  888.     BYTE CLASS,TYPE,CHARAC,LENGTH
  889.     INTEGER*2 WIDTH,SPEED
  890.     EQUIVALENCE(CHARACTER,CHARAC)
  891.  
  892. c  sense current terminal driver mode
  893.     ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SENSEMODE),,,,
  894.     1 CLASS,,,,,)
  895.     IF (.NOT.ISTAT) CALL ERROR('TERMINAL SENSEMODE',ISTAT)
  896.  
  897.     IF(SWITCH) THEN
  898. c  turn on 8 bit passall
  899.             CHARACTER=CHARACTER.OR.TT$M_PASSALL.OR.
  900.     1                               TT$M_EIGHTBIT
  901.     ELSE
  902. c  turn off 8 bit passall
  903.             CHARACTER=CHARACTER.AND..NOT.TT$M_PASSALL.AND.
  904.     1                               .NOT.TT$M_EIGHTBIT
  905.     ENDIF
  906.     SPEED=0 !LEAVE SPEED UNCHANGED
  907.     PAR=0   !LEAVE PARITY UNCHANGED
  908.  
  909. c  set terminal mode with desired passall
  910.     ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE),,,,
  911.     1               CLASS,,%VAL(SPEED),,%VAL(PAR),)
  912.     IF (.NOT.ISTAT) CALL ERROR('TERMINAL SETMODE',ISTAT)
  913.     RETURN
  914.     END
  915. c---------------------------------------------------
  916.     SUBROUTINE ERROR(STRING,MSGID)
  917. c               Types error message
  918.     IMPLICIT INTEGER(A-Z)
  919.     CHARACTER*(*) STRING
  920.     CHARACTER*80 MESSAGE
  921.  
  922.     TYPE *,' *** ERROR: ',STRING
  923. D    WRITE(8,*) ' *** ERROR: ',STRING
  924.     CALL SYS$GETMSG(%VAL(MSGID),MSGLEN,MESSAGE,%VAL(15),)
  925.     TYPE *,MESSAGE(1:MSGLEN),CRLF
  926. D    WRITE(8,*) MESSAGE(1:MSGLEN),CRLF
  927.     RETURN
  928.     END
  929. c-----------------------------------------------------------
  930.     subroutine cancel
  931.  
  932.         INTEGER*2 CHAN,STATUS(4)
  933.         COMMON /QIO/ CHAN,STATUS
  934. c  called to cancel send (at least)
  935.     logical charintime,ttyinlim
  936.     byte c
  937.     parameter CAN=24
  938.     parameter SPACE=32
  939.  
  940. c  eat garbage
  941.   100   charintime=ttyinlim(c,1,1)
  942.     if(.NOT.charintime) goto 100
  943. c  cancel other end
  944.     call ttyout(CAN,1)
  945.  
  946. c  eat garbage in case it didn't understand ?
  947.   200   charintime=ttyinlim(c,1,1)
  948.     if(.NOT.charintime) goto 200
  949. c  clear the CAN from far end's input  ???? why ? xmodem50.asm does it
  950.     call ttyout(SPACE,1)
  951.  
  952. c       print*,' XMODEM program canceled'
  953. D    WRITE(8,*)' XMODEM program canceled'
  954.     call exit
  955.     end
  956. c------------------------------------------------------
  957.     subroutine getack(acked)
  958. c  returns .TRUE. if gets ACK
  959.     logical charintime, ttyinlim, acked
  960.     byte sector(130),c
  961.  
  962.     integer errorcount
  963.     common /err/errorcount
  964.  
  965.     parameter ACK=6
  966.     parameter errlim=10     ! max number of errors
  967.     parameter eotlim=10     ! seconds to wait for eot
  968.  
  969. c       print*,' inside getack'
  970. c  empty typeahead in case garbage
  971. c       charintime=ttyinlim(sector,130,0)
  972. c  allow time for file close at other end.
  973.     charintime=ttyinlim(c,1,eotlim)
  974. c       print*,' getack got',c
  975.     if( .NOT.charintime .OR. c.NE.ACK ) then
  976. c               print*, ' not ACK, decimal=',c
  977. D    WRITE(8,*) ' not ACK, decimal=',c
  978.             errorcount=errorcount+1
  979.             if(errorcount.GE.errlim) then
  980. D    WRITE(8,*) ' not acknowleged in 10 tries.'
  981.                     print*,' Can''t send sector. Aborting.'
  982.                     call exit
  983.             endif
  984.             acked=.FALSE.
  985.     else
  986. c  received ACK
  987.             acked=.TRUE.
  988.     endif
  989.     return
  990.     end
  991.     subroutine delay(d)
  992.     t=secnds(0.0)
  993. 10    if(secnds(t).lt.d)go to 10
  994.     return
  995.     end
  996.     subroutine readxmmac(file,macname,nchars,type,creator,
  997.     1    ldata,lres,icreated,modified)
  998. c    *********************************************************
  999. c    *                            *
  1000. c    *    This subprogram copyright (c) 1985 by        *
  1001. c    *    Eye Research Institute of Retina Foundation    *
  1002. c    *        ALL RIGHTS RESERVED            *
  1003. c    *                            *
  1004. c    *********************************************************
  1005.     character file*(*),macname*(*),type*4,creator*4
  1006.     byte version,ncharsbyte
  1007.     character name*63,filler*10
  1008.     open(unit=1,file=file,status='old',readonly
  1009.     1        ,form='unformatted')
  1010.     read(1)version,ncharsbyte,name,type,creator,filler,
  1011.     1        ldata,lres,icreated,modified
  1012.     close(unit=1)
  1013.     nchars=ncharsbyte
  1014. c
  1015.     call flip4(ldata)
  1016.     call flip4(lres)
  1017.     call flip4(icreated)
  1018.     call flip4(modified)
  1019. c
  1020.     macname=name(1:nchars)
  1021.     return
  1022.     end
  1023.     subroutine flip4(i)
  1024. c    *********************************************************
  1025. c    *                            *
  1026. c    *    This subprogram copyright (c) 1985 by        *
  1027. c    *    Eye Research Institute of Retina Foundation    *
  1028. c    *        ALL RIGHTS RESERVED            *
  1029. c    *                            *
  1030. c    *********************************************************
  1031.     integer*4 i,j
  1032.     byte k(4),temp
  1033.     equivalence(j,k)
  1034.     j=i
  1035. c
  1036.     temp=k(1)
  1037.     k(1)=k(4)
  1038.     k(4)=temp
  1039. c
  1040.     temp=k(2)
  1041.     k(2)=k(3)
  1042.     k(3)=temp
  1043. c
  1044.     i=j
  1045.     return
  1046.     end
  1047.     subroutine mactext(infile,outfile)
  1048. c    *********************************************************
  1049. c    *                            *
  1050. c    *    This subprogram copyright (c) 1985 by        *
  1051. c    *    Eye Research Institute of Retina Foundation    *
  1052. c    *        ALL RIGHTS RESERVED            *
  1053. c    *                            *
  1054. c    *********************************************************
  1055.     implicit integer(a-z)
  1056.     character*(*)infile,outfile
  1057.     character buf*128,line*300
  1058.     character name*63,filler*10,type*4,creator*4
  1059.     character c
  1060.     character*20 x1,x2
  1061.     byte version,ncharsbyte
  1062.     call readxmmac(infile,name,nchars,type,creator,
  1063.     1        ldata,lres,icreated,modified)
  1064.     if(type.ne.'TEXT')then
  1065.         write(*,*)infile//'--bad, type = '//type//
  1066.     1        ' (should be TEXT)'
  1067.         write(*,*)'No file written'
  1068.         return
  1069.     end if
  1070.     iwrap=intparam('WRAP',79)
  1071.     open(unit=1,file=infile,status='old',form='unformatted',readonly,
  1072.     1    defaultfile='.mac')
  1073.     open(unit=2,file=outfile,status='new',carriagecontrol='list',
  1074.     1    form='formatted',defaultfile='.txt')
  1075.     read(1)buf
  1076.     b=128
  1077.     l=0
  1078.     break=0
  1079.     do 1000 i=1,ldata
  1080.     if(b.ge.128)then
  1081.         read(1)buf
  1082.         b=0
  1083.     endif
  1084.     b=b+1
  1085.     c=buf(b:b)
  1086.     if(c.eq.char(13) .or. i.eq.ldata)then
  1087.         if(l.gt.0)then
  1088.             write(2,100)line(1:l)
  1089. 100            format(a)
  1090.         else
  1091.             write(2,100)
  1092.         endif
  1093.         l=0
  1094.         break=0
  1095.     else
  1096.         l=l+1
  1097.         line(l:l)=c
  1098.         if(c.eq.' ')break=l
  1099.         if(l.ge.iwrap.and.break.ne.0)then
  1100.             write(2,100)line(1:break-1)
  1101.             line=line(break+1:)
  1102.             l=l-break
  1103.             break=0
  1104.         endif
  1105.     endif
  1106. 1000    continue
  1107.     close(1)
  1108.     close(2)
  1109.     return
  1110.     end
  1111.     subroutine textmac(infile,outfile)
  1112. c    *********************************************************
  1113. c    *                            *
  1114. c    *    This subprogram copyright (c) 1985 by        *
  1115. c    *    Eye Research Institute of Retina Foundation    *
  1116. c    *        ALL RIGHTS RESERVED            *
  1117. c    *                            *
  1118. c    *********************************************************
  1119.     implicit integer(a-z)
  1120.     character*(*)infile,outfile
  1121.     character header*128,buf*128,line*300,fullname*80
  1122.     byte version,ncharsbyte
  1123.     character name*63,filler*10,type*4,creator*4
  1124. c
  1125.     open (unit=1,file=infile,status='old',defaultfile='.txt',
  1126.     1    readonly)
  1127.     inquire(unit=1,name=fullname)
  1128.     open (unit=2,file=outfile,status='new',recl=128,access='direct',
  1129.     1    recordtype='fixed',defaultfile='.mac')
  1130.     block=1
  1131.     nchars=0
  1132.     nbuf=0
  1133.     buf=' '
  1134.     last=0
  1135. 100    continue
  1136.     read(1,110,end=200)n,line
  1137. 110    format(q,a)
  1138.     n=n+1
  1139.     line(n:n)=char(13)
  1140.     do 120 i=1,n
  1141.     nbuf=nbuf+1
  1142.     nchars=nchars+1
  1143.     buf(nbuf:nbuf)=line(i:i)
  1144.     if(nbuf.ge.128)then
  1145.         block=block+1
  1146.         write(2'block)buf(1:128)
  1147.         nbuf=0
  1148.         buf=' '
  1149.     end if
  1150. 120    continue
  1151.     go to 100
  1152. 200    continue
  1153.     block=block+1
  1154.     write(2'block)buf(1:128)
  1155. c
  1156.     version=0
  1157.     i1=index(fullname,']')+1
  1158.     i2=index(fullname,';')-1
  1159.     ncharsbyte=i2-i1+1
  1160.     name=fullname(i1:i2)
  1161.     type='TEXT'
  1162.     creator='MACA'
  1163.     filler=' '
  1164.     ldata=nchars
  1165.     lres=0
  1166.     call todaymac(icreated)
  1167.     modified=icreated
  1168. c
  1169.     call flip4(ldata)
  1170.     call flip4(lres)
  1171.     call flip4(icreated)
  1172.     call flip4(modified)
  1173.     write(2'1)version,ncharsbyte,name,type,creator,filler,
  1174.     1        ldata,lres,icreated,modified
  1175.     close(1)
  1176.     close(2)
  1177.     return
  1178.     end
  1179.     subroutine todaymac(mac)
  1180. c    *********************************************************
  1181. c    *                            *
  1182. c    *    This subprogram copyright (c) 1985 by        *
  1183. c    *    Eye Research Institute of Retina Foundation    *
  1184. c    *        ALL RIGHTS RESERVED            *
  1185. c    *                            *
  1186. c    *********************************************************
  1187.     character*32 today,macdate
  1188.     integer vax(2),offset(2),macstart(2)
  1189.     call lib$emul(65536*16384,40000000,0,offset)
  1190.     call sys$bintim('1-JAN-1904 00:00:00.00',macstart)
  1191.     call lib$date_time(today)
  1192.     call sys$bintim(today,vax)
  1193.     call lib$subx(vax,macstart,vax)
  1194.     call lib$subx(vax,offset,vax)
  1195.     call lib$ediv(10000000,vax,mac,irem)
  1196.     return
  1197.     end
  1198.     subroutine timemacvax(mac,vax)
  1199. c    *********************************************************
  1200. c    *                            *
  1201. c    *    This subprogram copyright (c) 1985 by        *
  1202. c    *    Eye Research Institute of Retina Foundation    *
  1203. c    *        ALL RIGHTS RESERVED            *
  1204. c    *                            *
  1205. c    *********************************************************
  1206.     integer vax(2),offset(2)
  1207. c
  1208. c    Mac is seconds since Jan 1, 1904
  1209. c    Vax is 100-nanosecond units since Nov 17, 1858
  1210. c
  1211. c    Convert units
  1212. c
  1213.     call lib$emul(mac,10000000,0,vax)
  1214. c
  1215. c    "Mac" should be interpreted as a 32-bit UNSIGNED integer.  For
  1216. c    dates since the Mac was built, the sign bit is set.  Offset calc.
  1217. c    is a kludge (idea is to get 65536*65536*10000000)
  1218. c
  1219.     if(mac.lt.0)then
  1220.         call lib$emul(65536*16384,40000000,0,offset)
  1221.         call lib$addx(offset,vax,vax)
  1222.     endif
  1223. c
  1224. c    Get VAX representation of Mac starting time
  1225. c
  1226.     call sys$bintim('1-JAN-1904 00:00:00.00',macstart)
  1227. c
  1228. c    Add starting time
  1229. c
  1230.     call lib$addx(macstart,vax,vax)
  1231.     return
  1232.     end
  1233.     character*(*) function macdate(mac)
  1234.     dimension vax(2)
  1235.     call timemacvax(mac,vax)
  1236.     call lib$sys_asctim(,macdate,vax)
  1237.     return
  1238.     end
  1239.     subroutine catalog
  1240. c    *********************************************************
  1241. c    *                            *
  1242. c    *    This subprogram copyright (c) 1985 by        *
  1243. c    *    Eye Research Institute of Retina Foundation    *
  1244. c    *        ALL RIGHTS RESERVED            *
  1245. c    *                            *
  1246. c    *********************************************************
  1247.     implicit integer(a-z)
  1248.     logical status,cli$present,cli$get_value
  1249.     character*80 infilespec,infile,temp
  1250.     character*16 file
  1251.     character*23 macdate,datecr,datemod
  1252. c
  1253.     character typecr*16,type*4,creator*4,name*63
  1254. c
  1255.     go to 1000
  1256. 10    continue
  1257.     nfound=0
  1258. 100    continue
  1259.     status=lib$find_file(infilespec,infile,context,'*.mac')
  1260.     if(status)then
  1261. c
  1262. c     Print header.  This way of doing it is supposed to make it
  1263. c        easier for me to modify the formats.
  1264.         nfound=nfound+1
  1265.         if(nfound.eq.1)then
  1266.             file='VMS name'
  1267.             name='Macintosh file'
  1268.             typecr='Type'
  1269.             datemod='Last modified'
  1270.             write(*,105)file(1:10),name(1:20),typecr,
  1271.     1            datemod
  1272.         endif
  1273. c
  1274.         call readxmmac(infile,name,nchars,type,creator,
  1275.     1        ldata,lres,icreated,modified)
  1276. c
  1277.         i1=index(infile,']')+1
  1278.         temp=infile(i1:)
  1279.         i2=index(temp,'.')-1
  1280.         file=temp(1:i2)
  1281. c
  1282.         datecr=macdate(icreated)
  1283.         datemod=macdate(modified)
  1284.         K=(ldata+1023)/1024 + (lres+1023)/1024
  1285. c
  1286.         if(creator.eq.'MACA')then
  1287.             typecr='MacWrite '//type
  1288.         else if(type .eq. 'APPL')then
  1289.             typecr='Application'
  1290.         else if(creator//type .eq. 'FMOVFFIL')then
  1291.             typecr='Font Mover file'
  1292.         else if(creator//type .eq. 'MPNTPNTG')then
  1293.             typecr='MacPaint'
  1294.         else if(creator//type .eq. 'MMMUMUSC')then
  1295.             typecr='MusicWorks'
  1296.         else
  1297.             typecr=creator//' '//type
  1298.         end if
  1299. c
  1300.         write(*,110)file(1:10),name(1:20),typecr,k,datemod(1:20)
  1301. 105        format(//1x,a,1x,a,1x,a,' Size  ',a/)
  1302. 110        format(1x,a,1x,a,1x,a,i4,3hK  ,a)
  1303.         go to 100
  1304.     endif
  1305. 1000    if(cli$get_value('file',infilespec))go to 10
  1306.     return
  1307.     end
  1308.  
  1309.